home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / p063b9s.zip / UNIT / SHRINK.PAS < prev    next >
Pascal/Delphi Source File  |  1992-12-06  |  6KB  |  171 lines
  1. unit Shrink;
  2.  
  3. { This unit allows you to allocate memory from the DOS memory pool rather than
  4.   from the Turbo Pascal heap.  It also provides a procedure for shrinking the
  5.   current program to free up DOS memory.  In protected mode, this allocates
  6.   memory from real mode addressable memory.
  7.  
  8.   Scott Bussinger
  9.   Professional Practice Systems
  10.   110 South 131st Street
  11.   Tacoma, WA  98444
  12.   (206)531-8944
  13.   Compuserve [72247,2671] }
  14.  
  15. { ** Revision History **
  16.   1 SHRINK.PAS 15-Sep-89,`SCOTT' Initial version of SHRINK unit
  17.   2 SHRINK.PAS 19-Oct-90,`SCOTT'
  18.            Added support for Turbo Pascal 6's new heap manager
  19.   3 SHRINK.PAS 27-Feb-91,`SCOTT'
  20.            Fixed problem in allocating memory in Turbo Pascal 6.0
  21.            Fixed missing variable for compilers prior to Turbo Pascal 6.0
  22.   4 SHRINK.PAS 9-Aug-92,23:29:46,`SCOTT'
  23.            Added compiler check for compatibility with BP 7
  24.   5 SHRINK.PAS 5-Dec-92,`SCOTT'
  25.            Complete compatibility with BP7 protected and real modes
  26.   ** Revision History ** }
  27.  
  28. interface
  29.  
  30. procedure DosNew(var P: pointer;
  31.                      Bytes: word);
  32.   { Get a pointer to a chunk of memory from DOS.  Returns NIL if
  33.     sufficient DOS memory is not available. }
  34.  
  35. procedure DosDispose(var P: pointer);
  36.   { Return an allocated chunk of memory to DOS.  Only call this function
  37.     with pointers allocated with DosNew or DosNewShrink. }
  38.  
  39. procedure DosNewShrink(var P: pointer;
  40.                            Bytes: word);
  41.   { Get a pointer to a chunk of memory from DOS, shrinking current program
  42.     to gain DOS memory if necessary.  Returns NIL if sufficient DOS memory
  43.     is not available and there is insufficient free space in the heap to
  44.     allow program to be shrunk to accomodate the request. }
  45.  
  46. implementation
  47.  
  48. {$DEFINE HEAP6}                                  { Define HEAP6 only if the Turbo 6 style heap is in effect }
  49.  
  50. {$IFDEF VER40}
  51. {$UNDEF HEAP6}
  52. {$ENDIF}
  53.  
  54. {$IFDEF VER50}
  55. {$UNDEF HEAP6}
  56. {$ENDIF}
  57.  
  58. {$IFDEF VER55}
  59. {$UNDEF HEAP6}
  60. {$ENDIF}
  61.  
  62. uses Dos
  63.      {$IFDEF DPMI}
  64.      ,WinAPI
  65.      {$ENDIF}
  66.      ;
  67.  
  68. const DosOverhead = 1;                           { Extra number of paragraphs that DOS requires in overhead for MCB chain }
  69.  
  70. function Linear(P: pointer): longint;
  71.   { Return the pointer as a linear longint value }
  72.   begin
  73.   Linear := (longint(seg(P^)) shl 4) + ofs(P^)
  74.   end;
  75.  
  76. procedure DosNew(var P: pointer;
  77.                      Bytes: word);
  78.   { Get a pointer to a chunk of memory from DOS.  Returns NIL if
  79.     sufficient DOS memory is not available. }
  80.   var DPMI: longint;
  81.       Regs: Registers;
  82.       SegsToAllocate: word;
  83.   begin
  84.   {$IFDEF DPMI}
  85.   P := ptr(GlobalDosAlloc(Bytes) and $FFFF,$0000)
  86.   {$ELSE}
  87.   SegsToAllocate := (Bytes+15) shr 4;            { DOS allocates memory in paragraph sized pieces only }
  88.   with Regs do
  89.     begin
  90.     AH := $48;
  91.     BX := SegsToAllocate;
  92.     MsDos(Regs);
  93.     if odd(Flags)
  94.      then
  95.       P := nil                                   { No memory available }
  96.      else
  97.       P := ptr(AX,$0000)                         { Return pointer to memory block }
  98.     end
  99.   {$ENDIF}
  100.   end;
  101.  
  102. procedure DosDispose(var P: pointer);
  103.   { Return an allocated chunk of memory to DOS.  Only call this function
  104.     with pointers allocated with DosNew or DosNewShrink. }
  105.   var DontCare: word;
  106.       Regs: Registers;
  107.   begin
  108.   {$IFDEF DPMI}
  109.   DontCare := GlobalDosFree(seg(P^))
  110.   {$ELSE}
  111.   with Regs do
  112.     begin
  113.     AH := $49;
  114.     ES := seg(P^);
  115.     MsDos(Regs)
  116.     end
  117.   {$ENDIF}
  118.   end;
  119.  
  120. procedure DosNewShrink(var P: pointer;
  121.                            Bytes: word);
  122.   { Get a pointer to a chunk of memory from DOS, shrinking current program
  123.     to gain DOS memory if necessary.  Returns NIL if sufficient DOS memory
  124.     is not available and there is insufficient free space in the heap to
  125.     allow program to be shrunk to accomodate the request. In protected mode
  126.     this just calls DosNew directly. }
  127.   var BytesToAllocate: word;
  128.       OldFreePtr: pointer;
  129.       Regs: Registers;
  130.   begin
  131.   DosNew(P,Bytes);                               { Try to get memory the easy way first }
  132.   {$IFNDEF DPMI}
  133.   {$IFDEF HEAP6}                                 { Check for Turbo 6's new heap manager }
  134.   BytesToAllocate := (((Bytes+15) shr 4) + DosOverhead) shl 4;
  135.   if (P=nil) and (Linear(HeapEnd)-Linear(HeapPtr)>=BytesToAllocate) then
  136.     begin                                        { The easy method didn't work but there is sufficient space in the heap }
  137.     dec(longint(HeapEnd),longint(BytesToAllocate) shl 12); { Move the top of the heap down }
  138.     with Regs do
  139.       begin
  140.       AH := $4A;
  141.       BX := seg(HeapEnd^) - prefixseg;
  142.       ES := prefixseg;
  143.       MsDos(Regs)
  144.       end;
  145.     DosNew(P,Bytes)                              { Try the DOS allocation one more time }
  146.     end
  147.   {$ELSE}
  148.   BytesToAllocate := (((Bytes+15) shr 4) + DosOverhead) shl 4;
  149.   if (P=nil) and                                 { Handle the old free list style heap }
  150.      (((ofs(FreePtr^)=0) and (Linear(FreePtr)+$10000-Linear(HeapPtr)>=BytesToAllocate)) or
  151.       ((ofs(FreePtr^)<>0) and (Linear(FreePtr)-Linear(HeapPtr)>=BytesToAllocate))) then
  152.     begin                                        { The easy method didn't work but there is sufficient space in the heap }
  153.     OldFreePtr := FreePtr;
  154.     dec(longint(FreePtr),longint(BytesToAllocate) shl 12); { Decrement the segment of the pointer to the free list }
  155.     if ofs(OldFreePtr^) <> 0 then                { If free list is empty, then there's nothing to move }
  156.       move(OldFreePtr^,FreePtr^,$10000-ofs(OldFreePtr^)); { Otherwise, move the free list down in memory }
  157.     with Regs do
  158.       begin
  159.       AH := $4A;
  160.       BX := seg(OldFreePtr^) + $1000 - prefixseg - (BytesToAllocate shr 4);
  161.       ES := prefixseg;
  162.       MsDos(Regs)
  163.       end;
  164.     DosNew(P,Bytes)                              { Try the DOS allocation one more time }
  165.     end
  166.   {$ENDIF}
  167.   {$ENDIF}
  168.   end;
  169.  
  170. end.
  171.